home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / akcl1615.lha / lsp / fasd.lisp < prev    next >
Lisp/Scheme  |  1990-08-15  |  5KB  |  152 lines
  1. (in-package 'si)
  2.  
  3. (require "FASDMACROS" "../cmpnew/fasdmacros.lsp")
  4. ;; (test '(a (1)) 2 12.0) -->   ((a (1)) 2 12.0)
  5.  
  6. (defmacro dprint (x)
  7.   `(if (and (boundp 'debug) debug)
  8.     (format t "~%The value of ~a is ~s" ',x ,x)))
  9.  
  10.  
  11.  
  12. (defun keep (x) (setq sil x))
  13. (defun test (&rest l &aux tab)
  14.   (with-open-file (st "/tmp/foo.l"
  15.               :direction :output )
  16.     (let* ((fd (open-fasd st :output nil (setq tab (make-hash-table :test 'eq)))))
  17.       (declare (special *fd*))
  18.       (si::find-sharing-top l tab)
  19. ;      (preprocess l tab)
  20.       (sloop::sloop for v in l
  21.             do
  22.             (write-fasd-top v fd)
  23.             finally (close-fasd fd))))
  24.   (test-in))
  25.  
  26. (defun preprocess1(lis table)
  27.   (cond ((symbolp lis)
  28.      (and lis
  29.           (let ((tem (gethash lis table)))
  30.         (cond (tem
  31.                (if (< (the fixnum tem) 0)
  32.              (setf (gethash lis table) (the fixnum (+ (the fixnum tem) -1)))))
  33.               (t (setf (gethash lis table) -1))))))
  34.     ((consp lis)
  35.      (preprocess1 (car lis) table)
  36.      (preprocess1 (cdr lis) table))
  37.     ((and (arrayp lis)
  38.           (eq (array-element-type lis) t))
  39.      (sloop::sloop for i below (length lis)
  40.                do (preprocess1 (aref (the (array t) lis) i) table)))
  41.     ((and (arrayp lis)
  42.           (eq (array-element-type lis) t))
  43.      (sloop::sloop for i below (length lis)
  44.                do (preprocess1 (aref (the (array t) lis) i) table)))
  45.     (t nil)))
  46.  
  47. (defun preprocess (lis table &aux freq)
  48.   (preprocess1 lis table)
  49.   (sloop:sloop for (ke val) in-table table
  50.            with m = 0 declare (fixnum m)
  51.            do ;(print (list ke val))
  52.            (cond((> (the fixnum val) 0)
  53.              (SETQ m (the fixnum (+ 1 m))))
  54.             ((< (the fixnum val) -1)
  55.              (remhash ke table)
  56.              (push (cons val ke) freq)))
  57.            finally (sloop::loop-return
  58.             (sort freq '> :key 'car ))))
  59.  
  60. (defun test-in ()
  61.   (with-open-file (st "/tmp/foo.l" :direction :input)
  62.       (let ((fdin (open-fasd st :input (setq eof '(nil)) (keep (make-array 10)))))
  63.     (sloop while (not (eq eof (setq tem (read-fasd-top fdin))))
  64.            collect tem
  65.            finally
  66.            (dprint fdin)
  67.            (close-fasd fdin)))))
  68.  
  69. (defun try-write (file &aux (tab (make-hash-table :test 'eq)) (eof '(nil)))
  70.   (with-open-file (st file)
  71.         (with-open-file (st1 "/tmp/foo.l" :direction :output)
  72.       (sloop  while (not (eq eof (setq tem (read st nil eof)))) with fd
  73.           collect (file-position st1)
  74.           do(clrhash tab)
  75.  
  76.           (setq fd (open-fasd st1 :output nil tab))
  77. ;          (let ((prp (preprocess tem tab)))
  78. ;            (dprint  prp))
  79.           (write-fasd-top tem fd)
  80.           (close-fasd fd)
  81.           (dprint tab)
  82.           ))))
  83. (defvar *differed* nil)
  84.  
  85. (defun try-read (file pos &aux (tab (make-array 10)) (eof '(nil)))
  86.   (with-open-file (st file)
  87.         (with-open-file (st1 "/tmp/foo.l")
  88.       (sloop  while (not (eq eof (setq tem (read st nil eof)))) with fd with re
  89.           for u in pos
  90.           do (file-position st1 u)
  91.           (setq fd (open-fasd st1 :input eof tab))
  92.           (sloop::sloop for i below (length tab) do (setf (aref (the (array (t)) tab) i) nil))
  93.           (setq re (read-fasd-top fd))
  94.           (dprint re)
  95.           (unless (equalp tem re)
  96.               (push (list tem re) *differed*))
  97.          ; (assert (eq eof (read-fasd-top fd)))
  98.           (close-fasd fd)))))
  99.  
  100. (defun try (file)
  101.   (let ((pos (try-write file)))
  102.     (try-read file pos)
  103.     (print file)
  104.     (system (format nil "cat ~a | wc ; cat /tmp/foo.l | wc " (namestring file)))
  105.     ))
  106.  
  107. (defvar *table* (make-hash-table :test 'eq))
  108. (defun do-share (x)
  109.   (si::find-sharing x *table*))
  110.  
  111.  
  112.  
  113.  
  114. (defun read-data-file (file)
  115.   (let ((pack-ops))
  116.     (set-dispatch-macro-character #\# #\!
  117.                   #'(lambda (st a b ) (setq pack-ops (read st nil nil) )))
  118.     (with-open-file (st file)
  119.       (let ((tem (read st nil nil)))
  120.     (list pack-ops tem)))))
  121.  
  122.  
  123. (defun write-out-data (lis fil)
  124.   (with-open-file (st fil :direction :output)
  125.     (let ((fd (open-fasd st :output nil (setq tab (make-hash-table :test 'eq)))))
  126.       (find-sharing-top lis (fasd-table fd))
  127.       (write-fasd-top (car lis) fd)
  128.       (write-fasd-top (second lis) fd)
  129. ;      (close-fasd fd)
  130.       fd)))
  131.  
  132. ;; To convert an ascii .data file to a fasd one. 
  133. ;(setq bil (si::read-data-file "vmlisp.data") her nil)
  134. ;(SI::WRITE-OUT-DATA1 (SECOND BIL) (FIRST BIL) "/tmp/foo.l")
  135. (defun write-out-data1 (data-vec pack-ops fil)
  136.   (with-open-file (st fil :direction :output)
  137.     (let ((compiler::*data* (list data-vec nil        pack-ops))
  138.       (compiler::*compiler-output-data* st)
  139.       (compiler::*fasd-data* (list (open-fasd st :output nil nil))))
  140.       (compiler::wt-fasd-data-file)
  141.       (car compiler::*fasd-data*))))
  142.  
  143.  
  144.          
  145.      
  146.      
  147.   
  148. ;(setq dirs (directory "/public/spad/libraries/A*/index.KAF*"))
  149. ;(mapcar 'try dirs)
  150.  
  151.  
  152.